\ MS Calendar Control Example
\ Tom Dixon
\ 9/4/2008

include FCOMbase
include ACTIVEX
also FCOM

\ Type library for MSCAL control
7 0 typelib {8E27C92E-1264-101C-8A2F-040224009C02}

ICalendar comiface Cal

: cal-init ( -- )
   Cal freeref
   Cal ICalendar 1 0 Calendar fCoCreateInstance
   Abort" Unable to Start MSCal Component!" ;

: cal-close ( -- ) Cal freeref ;

: Day ( -- d )      pad Cal GetDay         drop pad @ ;
: Month ( -- m )    pad Cal GetMonth       drop pad @ ;
: MonthLen ( -- m ) pad Cal GetMonthLength drop pad @ ;
: Year ( -- y )     pad Cal GetYear        drop pad @ ;

: Day! ( d -- )   Cal PutDay drop ;
: Month! ( m -- ) Cal PutMonth drop ;
: Year! ( y -- )  Cal PutYear drop ;


\ Using it as an ActiveX control
\ (Code has been shamelessly copied from the Vfx examples)


\ =====================================================
\ Define a Window resource Template for the Main Window
\ =====================================================

NULL value hChild
NULL value hWindow

NextID:	IDW_MAINWINDOW

IDW_MAINWINDOW WINDOW 0, 0, 300, 300
BEGIN
   Caption         "ActiveX Window"
   Style           WS_POPUP | WS_BORDER | WS_SYSMENU |
                   WS_CAPTION | WS_THICKFRAME | WS_MINIMIZEBOX |
                   WS_MAXIMIZEBOX | WS_CLIPSIBLINGS | WS_VISIBLE
   ClassStyle      CS_HREDRAW | CS_VREDRAW
   Icon            IDI_APPLICATION
   Cursor          IDC_ARROW
   Brush           WHITE_BRUSH
   Menu            NULL
   WndProc         TestWindowProc
END

: Resize-Child ( lparam -- )
  hChild 0 rot 0 swap
  dup $FFFF and swap 16 rshift $FFFF and
  1 MoveWindow drop ;

: TestWindowProc	\ hWnd uMessage wParam lParam -- res
  { hWnd uMessage wParam lParam }

  uMessage case
    WM_CREATE  of  hWnd -> hWindow 1  endof
    WM_SIZE    of  lParam Resize-Child 0  endof
    WM_DESTROY of  0 -> hWindow 1  endof
    drop hWnd uMessage wParam lParam DefWindowProc
  end-case
;

\ =====================================================
\ Child window that will host the ActiveX control
\ =====================================================

NextID:	IDW_Child

IDW_Child WINDOW    0, 0, 300, 280
BEGIN
        Caption     "ActiveX child window"
        Style       WS_VISIBLE | WS_THICKFRAME | CCS_NORESIZE
        ClassStyle  CS_HREDRAW | CS_VREDRAW
        Icon        IDI_APPLICATION
        Cursor      IDC_ARROW
        Brush       WHITE_BRUSH
        Menu        NULL
        WndProc     ChildWindowProc
END

: ChildWindowProc	{ hwnd mesg wparam lparam -- ior }
  case mesg
    WM_CREATE of
      hwnd -> hChild  1
    endof

    WM_DESTROY of
      0 -> hChild  1			\ so that default is performed
    endof
      drop  hwnd mesg wparam lparam DefWindowProc
  end-case
;

: RunChild	\ --
  hChild 0= if
    IDW_Child hWindow RESOURCE::CreateChildWindow -> hChild
    s" MSCAL.Calendar" hChild AXCreate
    Cal freeref
    Cal ICalendar hChild AXQuery
  endif
;

: CloseChild	\ --
  hChild if
    cal-close
    hChild SendClose
  endif
;

: Run ( -- )
  hWindow 0= if
    IDW_MAINWINDOW Resource::CreateParentWindow -> hWindow
    RunChild
  endif
;

: Close ( -- )
  hWindow if
    CloseChild
    hWindow SendClose
  endif ;

: .date ( -- )
  ." Date Selected: "
  Day 0 .r ." /" Month 0 .r ." /" Year . cr ;

cr
.( Type 'Run' to start the demo ) cr
.( Type 'Close' to stop the demo ) cr
.( type '.date' to see the selected date ) cr
cr

free-lasttypelib
previous
